home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / data.lisp < prev    next >
Text File  |  1993-07-17  |  23KB  |  638 lines
  1. ;-*- SYNTAX: ZETALISP; BASE: 10; MODE: LISP; PACKAGE: BOXER; FONTS: CPTFONT,CPTFONTB -*-
  2.  
  3. #|
  4.             Copyright 1985 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                     This file is part of the BOXER system
  18.  
  19. This file contains the top level definitions for the system supplied Data Manipulation
  20. Primitives for the BOXER System.
  21.  
  22. They are divided into
  23.  
  24. INFORMATION
  25.  
  26.    EMPTY?
  27.    NUMBER-OF <box> <specifier>
  28.    ITEM-NUMBER-OF <box> <item> <occurence>
  29.  
  30. ACCESSORS
  31.  
  32.  Item(s) Accessors:
  33.    FIRST <box> 
  34.    BUTFIRST <box>
  35.    START <box>
  36.    BUTSTART <box>
  37.    LAST <box>
  38.    BUTLAST <box>
  39.    ITEM <item number> <box>
  40.    BUTITEM <item number> <box>
  41.    GET-NTH <box> <item number>
  42.    RC <row> <column> <box>
  43.    GET-RC <box> <row> <column>
  44.    ITEMS <item numbers> <box>
  45.  
  46.  Row Accessors:
  47.    FIRST-ROW <box>
  48.    BUTFIRST-ROW <box>
  49.    LAST-ROW <box>
  50.    BUTLAST-ROW <box>
  51.    ROW <row number> <box>
  52.    BUTROW <row number> <box>
  53.  
  54.  
  55. CONSTRUCTORS
  56.  
  57.   MAKE-EMPTY-BOX
  58.   BOXIFY
  59.   JOIN-RIGHT  <box1> <box2>
  60.   JOIN-BOTTOM <box1> <box2>
  61.   BUILD <template box>
  62.  
  63.  
  64. MUTATORS
  65.  
  66.  Item Mutators:
  67.    CHANGE-ITEM <n> <box> <new-item>
  68.    CHANGE-RC   <row> <column> <box> <new-item>
  69.    DELETE-ITEM <n> <box>
  70.    DELETE-RC   <row> <column> <box>
  71.    INSERT-ITEM <n> <box> <new-item>
  72.    INSERT-RC   <row> <column> <box> <new-item>
  73.  
  74. Row Mutators:
  75.   CHANGE-ROW <row number> <box> <new row>
  76.   DELETE-ROW <row number> <box>
  77.   INSERT-ROW <row number> <box> <new row>
  78.  
  79. |#
  80.  
  81.  
  82.  
  83. (DEFVAR *TRIM-EMPTY-ROWS?* T)
  84.  
  85. ;;; utilities for data manipulation
  86. ;; these handle selecting parts of ports...
  87. ;; CONS up new EVROWs with the appropriate elements (i.e. copies or ports)
  88.  
  89. ;; ROW is a list of items.  
  90. (DEFUN PROCESS-ROW-FOR-SELECTOR (ROW PORT?)
  91.   (COND ((NULL ROW)
  92.      (MAKE-EMPTY-EVROW))
  93.     ((AND PORT? (LISTP ROW))
  94.      (MAKE-EVROW-FROM-ITEMS (PORT-TO-INFERIORS-IN-LIST ROW t)))
  95.     ((LISTP ROW)                ;;should be frobbing the items here too
  96.      (MAKE-EVROW-FROM-ITEMS ROW))
  97.     (T (FERROR "Don't know how to make a row from ~A " ROW))))
  98.  
  99. (DEFSUBST GET-ROWS-FOR-SELECTOR (BOX)
  100.   (MAPCAR #'(LAMBDA (ROW) (PROCESS-ROW-FOR-SELECTOR ROW (EVAL-PORT? BOX)))
  101.       (GET-BOX-ROWS BOX T)))
  102.  
  103. (DEFSUBST GET-FIRST-ROW-FOR-SELECTOR (BOX)
  104.   (PROCESS-ROW-FOR-SELECTOR (GET-FIRST-ROW BOX T) (EVAL-PORT? BOX)))
  105.  
  106. (DEFSUBST GET-NTH-ROW-FOR-SELECTOR (N BOX)
  107.   (PROCESS-ROW-FOR-SELECTOR (GET-NTH-ROW N BOX) (EVAL-PORT? BOX)))
  108.  
  109. ;;; BUILD and friends use this
  110. ;;; returns the next element in the row that is currently being built along with its length
  111. ;;; IF there happens to be an UNBOX, then a list of items is handed back to the caller
  112. ;;; (presumably PROCESS-ROW-FOR-BUILD) to be spliced in.  If the UNBOX results in multiple
  113. ;;; rows, then the other rows are passed back to the caller as a third value
  114. (DEFUN PROCESS-ROW-ELEMENT-FOR-BUILD (EL)
  115.   (DECLARE (VALUES RESULT LENGTH OTHER-ROWS EVALED?))
  116.   (COND ((EVAL-IT-TOKEN? EL)
  117.      (LET ((RESULT (EV-THING (EVAL-IT-TOKEN-ELEMENT EL))))
  118.        (VALUES (cond ((and (eval-box? result)
  119.                    (or (graphics-box? result)
  120.                    (graphics-data-box? result)
  121.                    (sprite-box? result)))
  122.               (copy-box result nil))
  123.              ((AND (OR (EVAL-BOX? RESULT) (EVAL-PORT? RESULT)))
  124.               (COPY-FOR-EVAL RESULT))
  125.              (t RESULT))
  126.            (CHA-LENGTH-OF-EVROW-ITEM RESULT)
  127.            NIL T)))
  128.     ((UNBOX-TOKEN? EL)
  129.      (LET ((ROWS (GET-BOX-ROWS
  130.                (UNBOX-PAIR-ELEMENT (EV-THING EL NIL)) T)))
  131.        (VALUES (CAR ROWS)
  132.            (LOOP FOR R IN ROWS MAXIMIZE (ITEM-LIST-LENGTH-IN-CHAS R))
  133.            (CDR ROWS) T)))
  134.     ((EVAL-PORT? EL)
  135.      (VALUES (SHALLOW-COPY-FOR-EVALUATOR EL) 1 NIL NIL))
  136.     ((EVAL-BOX? EL)
  137.      (MULTIPLE-VALUE-BIND (RESULT E?)
  138.          (BUILD-INTERNAL EL t)
  139.      (VALUES RESULT 1 NIL E?)))
  140.     (T (VALUES EL (CHA-LENGTH-OF-EVROW-ITEM EL)))))
  141.  
  142. (DEFUN MERGE-UNBOXED-ROWS (CURRENT-ROWS NEW-ROWS CURRENT-LENGTH INC-LENGTH)
  143.   (LOOP FOR INDEX FROM 0 TO (1- (MAX (LENGTH CURRENT-ROWS) (LENGTH NEW-ROWS)))
  144.     FOR CURRENT-ROW = (NTH INDEX CURRENT-ROWS)
  145.     FOR NEW-ROW     = (NTH INDEX NEW-ROWS)
  146.     COLLECTING
  147.       (IF (NULL CURRENT-ROW)
  148.           (APPEND (NCONS (MAKE-SPACES CURRENT-LENGTH))
  149.               NEW-ROW)
  150.           (APPEND CURRENT-ROW            ;what is already there
  151.               ;; fill with spaces so rows will line up
  152.               (NCONS (MAKE-SPACES (- (+ CURRENT-LENGTH INC-LENGTH)
  153.                          (EVROW-LENGTH-IN-CHAS CURRENT-ROW)
  154.                          (EVROW-LENGTH-IN-CHAS NEW-ROW))))
  155.           NEW-ROW))))
  156.  
  157. ;; Remember, one row in a BUILD template may be able to produce several rows in the result
  158. ;; due to imbedded !'s and @'s
  159.  
  160. (DEFUN PROCESS-ROW-FOR-BUILD (ROW)
  161.  "Returns a list of rows to be APPENDed into the final result. "
  162.  (DECLARE (VALUES LIST-OF-ROWS EXCLS-OR-ATSIGNS?))
  163.   (LOOP WITH RETURN-ROW = NIL
  164.     WITH AUX-ROWS = NIL
  165.     WITH CURRENT-LENGTH = 0
  166.     WITH EXCLS-OR-ATSIGNS? = NIL
  167.     FOR ELEMENT IN ROW
  168.     DO (MULTIPLE-VALUE-BIND (RESULT LENGTH OTHER-ROWS EVALED?)
  169.            (PROCESS-ROW-ELEMENT-FOR-BUILD ELEMENT)
  170.          (WHEN (NOT-NULL OTHER-ROWS)
  171.            (SETQ AUX-ROWS
  172.              (MERGE-UNBOXED-ROWS AUX-ROWS OTHER-ROWS CURRENT-LENGTH LENGTH)))
  173.          (SETQ RETURN-ROW (APPEND RETURN-ROW (LIST-OR-LISTIFY RESULT)))
  174.          (INCF CURRENT-LENGTH LENGTH)
  175.          (SETQ EXCLS-OR-ATSIGNS? (OR EXCLS-OR-ATSIGNS? EVALED?))
  176.          (WHEN (NOT-NULL OTHER-ROWS)
  177.            (LET ((TOP-ROW-PAD (- CURRENT-LENGTH (ITEM-LIST-LENGTH-IN-CHAS RETURN-ROW))))
  178.          (WHEN (> TOP-ROW-PAD 0)
  179.            (SETQ RETURN-ROW (ADD-SPACES-TO-RIGHT RETURN-ROW TOP-ROW-PAD))))))
  180.     FINALLY
  181.       (RETURN (VALUES (MAPCAR #'MAKE-EVROW-FROM-ITEMS
  182.                   (APPEND (NCONS RETURN-ROW) AUX-ROWS))
  183.               EXCLS-OR-ATSIGNS?))))
  184.  
  185. ;;; BUILD caching
  186. ;; A flag is associated with each box indicating whether there are any !'s or @'s in it's 
  187. ;; substructure
  188. ;; currently, we can only cache builds in the PLIST of a REAL box
  189. ;; Un-mutated virtual copies can track back to the parent to access this flag
  190. ;; A consequence of this is that BUILD is now a flavor of input because that is the only
  191. ;; place where we can get our hands on a real live editor box (i.e. something that is not 
  192. ;; copied or ported-to). Although in the current shallow copy, 
  193. ;; the next level of sub-boxes of any "copy" can also be "real" boxes
  194. ;; An alternative to this is to copy the build cache (or a flag which
  195. ;; specifies whether deep scanning of the box is required) when ever we make a copy of the 
  196. ;; box.  This will win in more cases but will make the box copies bigger and slower to create.
  197. ;; If we encourage pervasive use of BUILD, then this may be the way to go since the current
  198. ;; caching scheme only wins at top level or with shallow copies.
  199. ;; The current implementation should survive virtual copy for all the wrong reasons
  200.  
  201. (DEFUN GET-CACHED-BUILD (BOX)
  202.   (AND (BOX? BOX) (TELL BOX :GET 'CACHED-BUILD)))
  203.  
  204. (DEFUN BUILD-INTERNAL (TEMPLATE &optional name-too)
  205.   (IF (GET-CACHED-BUILD TEMPLATE)
  206.       (COPY-FOR-EVAL TEMPLATE)
  207.       (LOOP WITH ROWS = NIL
  208.         WITH EXCLS-OR-ATSIGNS? = NIL
  209.         FOR ROW IN (GET-BOX-ROWS TEMPLATE)
  210.         DO (MULTIPLE-VALUE-BIND (NEW-ROWS EXS-OR-ATS)
  211.            (PROCESS-ROW-FOR-BUILD ROW)
  212.          (SETQ ROWS              (APPEND ROWS NEW-ROWS)
  213.                EXCLS-OR-ATSIGNS? (OR EXCLS-OR-ATSIGNS? EXS-OR-ATS)))
  214.         FINALLY
  215.           (LET ((RESULT (COND ((EVAL-DOIT? TEMPLATE) (MAKE-EVDOIT ROWS ROWS))
  216.                   ((EVAL-DATA? TEMPLATE) (MAKE-EVDATA ROWS ROWS))
  217.                   (T (FERROR "Don't know how to BUILD ~A's"
  218.                          (TYPEP TEMPLATE))))))
  219.         ;; handle names of inferior objects
  220.         (when (and name-too (not (null (box-name template))))
  221.           (setf (%evbox-name result) (box-name template)))
  222.         (WHEN (AND (NULL EXCLS-OR-ATSIGNS?) (BOX? TEMPLATE))
  223.           (TELL TEMPLATE :PUTPROP T 'CACHED-BUILD))
  224.         (RETURN (VALUES RESULT EXCLS-OR-ATSIGNS?))))))
  225.  
  226. ;; use this to handle the resulting namespace from data selectors
  227.  
  228. (DEFUN UPDATE-BINDINGS-LIST (UNWANTED BINDINGS)
  229.   (IF (NOT (LISTP UNWANTED)) (DELQ (RASSQ UNWANTED BINDINGS) BINDINGS)
  230.       (LOOP WITH NEW-BINDINGS = BINDINGS
  231.         FOR UNWANTED-BINDING IN UNWANTED
  232.         FOR EXISTING-PAIR = (RASSQ UNWANTED-BINDING NEW-BINDINGS)
  233.         WHEN (NOT-NULL EXISTING-PAIR)
  234.           DO (SETQ NEW-BINDINGS (DELQ EXISTING-PAIR NEW-BINDINGS))
  235.         FINALLY (RETURN NEW-BINDINGS))))
  236.  
  237.  
  238.  
  239. ;;;; Accessor primitives
  240. ;;;  1 based
  241.  
  242. (DEFUN ITEM (N BOX)
  243.   "Returns the desired item in a Box.  If N < 1 or > number of elements then an empty box is returned. "
  244.   (COND (( 1 N (GET-BOX-LENGTH-IN-ELEMENTS BOX))
  245.      (MULTIPLE-VALUE-BIND (ROW COL)
  246.          (GET-ROW-AND-COL-NUMBER N BOX)
  247.        (MAKE-EVDATA
  248.          ROWS
  249.          (NCONS (MAKE-EVROW-FROM-ENTRY
  250.               (GET-NTH-ELEMENT-IN-EVROW COL (GET-NTH-ROW-FOR-SELECTOR ROW BOX)))))))
  251.     (T (MAKE-EMPTY-EVBOX))))
  252.  
  253. (DEFUN BUTITEM (N BOX)
  254.   "Returns a Box with all the same elements as BOX except for element N. "
  255.   (COND ((EVAL-EMPTY? BOX)
  256.      (MAKE-EMPTY-EVBOX))
  257.     (( 1 N (GET-BOX-LENGTH-IN-ELEMENTS BOX))
  258.      (MULTIPLE-VALUE-BIND (ROW-NO COL)
  259.          (GET-ROW-AND-COL-NUMBER N BOX)
  260.        (LET* ((ROWS (GET-ROWS-FOR-SELECTOR BOX))
  261.           (ROW (NTH ROW-NO ROWS)))
  262.          (SETF (NTH ROW-NO ROWS) (GET-BUTNTH-ELEMENT-IN-EVROW COL ROW))
  263.          (MAKE-EVDATA ROWS (IF *TRIM-EMPTY-ROWS?*
  264.                    (TRIM-EMPTY-ROWS ROWS)
  265.                    ROWS)))))
  266.     (T (COPY-FOR-EVAL BOX))))
  267.  
  268.  
  269.  
  270. ;;;; Information about data objects...
  271. ;;; EMPTY?, NUMBER-OF, and ITEM-NUMBER-OF?
  272.  
  273. (DEFBOXER-FUNCTION EMPTY? (ITEM)
  274.   (BOXER-BOOLEAN (EVAL-EMPTY? ITEM)))
  275.  
  276. (DEFBOXER-FUNCTION NUMBER-OF (BOX SPECIFIER)
  277.   (LET ((KEYWORD (GET-FIRST-ELEMENT SPECIFIER)))
  278.     (SELECTQ KEYWORD
  279.       ((BU:ROW BU:ROWS)
  280.        (BOXIFY (GET-BOX-LENGTH-IN-ROWS BOX)))
  281.       ((BU:COL BU:COLUMNS BU:COLS BU:COLUMN)
  282.        (BOXIFY (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
  283.              MAXIMIZE (LENGTH ROW))))
  284.       ((BU:ITEM BU:ITEMS)
  285.        (BOXIFY (GET-BOX-LENGTH-IN-ELEMENTS BOX)))
  286.       ((BU:RC BU:ROWS-COLUMNS)
  287.        (MAKE-EVDATA ROWS
  288.             (NCONS (make-evrow-from-items
  289.                  (list
  290.                    (GET-BOX-LENGTH-IN-ROWS BOX)
  291.                    (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
  292.                      MAXIMIZE (LENGTH ROW)))))))
  293.       (OTHERWISE
  294.        (BOXER-ERROR "Don't know How to find the number of ~A's" KEYWORD)))))
  295.  
  296. (DEFBOXER-FUNCTION ITEM-NUMBER-OF (BOX ITEM (NUMBERIZE OCCURENCE))
  297.   (LOOP FOR I FROM 1 TO (GET-BOX-LENGTH-IN-ELEMENTS BOX)
  298.     FOR BOX-ITEM = (ITEM I BOX)
  299.     WHEN (BOX-EQUAL? BOX-ITEM ITEM)
  300.       DO (IF (= 1 (NUMBERIZE OCCURENCE))
  301.          (RETURN (BOXIFY I))
  302.          (SETF OCCURENCE (- OCCURENCE 1)))
  303.     FINALLY
  304.       (RETURN (MAKE-EMPTY-EVBOX))))
  305.  
  306. (DEFBOXER-FUNCTION ITEM-NUMBERS-OF (BOX ITEM)
  307.   (LOOP FOR I FROM 1 TO (GET-BOX-LENGTH-IN-ELEMENTS BOX)
  308.     FOR BOX-ITEM = (ITEM I BOX)
  309.     WHEN (BOX-EQUAL? BOX-ITEM ITEM)
  310.       COLLECT I INTO INOS
  311.     FINALLY
  312.       (RETURN (boxify-list inos))))
  313.  
  314. ;;;; Item Accessors....
  315. ;;; FIRST, BUTFIRST, START, BUTSTART, LAST, BUTLAST, ITEM, BUTITEM, GET-NTH, ITEMS
  316. ;;; Empty rows are NOT currently ignored
  317.  
  318. ;; this version of FIRST unboxes
  319. (DEFBOXER-FUNCTION FIRST (BOX)
  320.   (ITEM 1 BOX))
  321.  
  322. (DEFBOXER-FUNCTION BUTFIRST (BOX)
  323.   (BUTITEM 1 BOX))
  324.  
  325. (DEFBOXER-FUNCTION BU:START (BOX)
  326.   (ITEM 1 BOX))
  327.  
  328. (DEFBOXER-FUNCTION BUTSTART (BOX)
  329.   (BUTITEM 1 BOX))
  330.  
  331. (DEFBOXER-FUNCTION LAST (BOX)
  332.   (ITEM (GET-BOX-LENGTH-IN-ELEMENTS BOX) BOX))
  333.  
  334. (DEFBOXER-FUNCTION BUTLAST (BOX)
  335.   (BUTITEM (GET-BOX-LENGTH-IN-ELEMENTS BOX) BOX))
  336.  
  337.  
  338.  
  339. (DEFBOXER-FUNCTION GET-NTH (BOX (NUMBERIZE N))
  340.   (ITEM N BOX))
  341.  
  342. ;;; the same as get-nth except that the args are in reverse order
  343. (DEFBOXER-FUNCTION ITEM ((NUMBERIZE N) BOX)
  344.   (ITEM N BOX))
  345.  
  346. (DEFBOXER-FUNCTION BUTITEM ((NUMBERIZE N) BOX)
  347.   (BUTITEM N BOX))
  348.  
  349. (DEFBOXER-FUNCTION GET-RC (BOX (NUMBERIZE ROW) (NUMBERIZE COL))
  350.   (COND ((> ROW (GET-BOX-LENGTH-IN-ROWS BOX))
  351.      (MAKE-EMPTY-EVBOX))
  352.     (T (LET ((ROW (NTH (1- ROW) (GET-ROWS-FOR-SELECTOR BOX))))
  353.          (COND ((> COL (EVROW-LENGTH-IN-ELEMENTS ROW))
  354.             (MAKE-EMPTY-EVBOX))
  355.            (T (MAKE-EVDATA
  356.             ROWS
  357.             (NCONS (MAKE-EVROW-FROM-ENTRY
  358.                  (GET-NTH-ELEMENT-IN-EVROW (1- COL) ROW))))))))))
  359.  
  360. (DEFBOXER-FUNCTION RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX)
  361.   (COND ((> ROW (GET-BOX-LENGTH-IN-ROWS BOX))
  362.      (MAKE-EMPTY-EVBOX))
  363.     (T (LET ((ROW (NTH (1- ROW) (GET-ROWS-FOR-SELECTOR BOX))))
  364.          (COND ((> COL (EVROW-LENGTH-IN-ELEMENTS ROW))
  365.             (MAKE-EMPTY-EVBOX))
  366.            (T (MAKE-EVDATA
  367.             ROWS
  368.             (NCONS (MAKE-EVROW-FROM-ENTRY
  369.                  (GET-NTH-ELEMENT-IN-EVROW (1- COL) ROW))))))))))
  370.  
  371. ;;; several items (by item number)
  372. (DEFBOXER-FUNCTION ITEMS (NOS BOX)
  373.   (LOOP WITH ITEMS = (GET-BOX-ELEMENTS BOX)
  374.     FOR EL IN (GET-BOX-ELEMENTS NOS)
  375.     COLLECTING (NTH (1- EL) ITEMS) INTO RETURN-ROW
  376.     FINALLY (RETURN (MAKE-EVDATA ROWS (NCONS (MAKE-EVROW-FROM-ENTRIES RETURN-ROW))))))
  377.       
  378.  
  379.  
  380. ;;; Row accessors
  381. ;;; FIRST-ROW, BUTFIRST-ROW, LAST-ROW, BUTLAST-ROW, ROW, BUTROW
  382.  
  383. (DEFUN ROW (N BOX)
  384.   "Returns a row N of box BOX inside a Box. "
  385.   (IF ( 1 N (GET-BOX-LENGTH-IN-ROWS BOX))
  386.       (MAKE-EVDATA ROWS (NCONS (GET-NTH-ROW-FOR-SELECTOR (1- N) BOX)))
  387.       (MAKE-EMPTY-EVBOX)))
  388.  
  389. (DEFBOXER-FUNCTION FIRST-ROW (BOX)
  390.   (ROW 1 BOX))
  391.  
  392. (DEFBOXER-FUNCTION BUTFIRST-ROW (BOX)
  393.   (LET ((ROWS (CDR (GET-ROWS-FOR-SELECTOR BOX))))
  394.     (MAKE-EVDATA ROWS (IF (NULL ROWS) '(()) ROWS))))
  395.  
  396. (DEFBOXER-FUNCTION LAST-ROW (BOX)
  397.   (ROW (GET-BOX-LENGTH-IN-ROWS BOX) BOX))
  398.  
  399. (DEFBOXER-FUNCTION BUTLAST-ROW (BOX)
  400.   (LET ((ROWS (BUTLAST (GET-ROWS-FOR-SELECTOR BOX))))
  401.     (MAKE-EVDATA ROWS (IF (NULL ROWS) '(()) ROWS))))
  402.  
  403. (DEFBOXER-FUNCTION ROW ((NUMBERIZE N) BOX)
  404.   (ROW N BOX))
  405.  
  406. (DEFBOXER-FUNCTION BUTROW ((NUMBERIZE N) BOX)
  407.   (LET ((ROWS (GET-ROWS-FOR-SELECTOR BOX)))
  408.     (IF (ZEROP N)
  409.     (MAKE-EVDATA ROWS ROWS)
  410.     (MAKE-EVDATA ROWS (APPEND (FIRSTN (1- N) ROWS) (NTHCDR N ROWS))))))
  411.  
  412. (DEFBOXER-FUNCTION GET-NAMED (NAME BOX)
  413.   (LET* ((SYMBOL (GET-FIRST-ELEMENT NAME))
  414.      (THING (LOOKUP-LOCAL-VARIABLE SYMBOL (GET-LOCAL-ENV BOX))))
  415.     (COND ((NULL THING) (MAKE-EMPTY-EVBOX))
  416.       ((FUNCTIONP THING) (BOXER-ERROR "Trying to boxify a primitive"))
  417.       (T (BOXIFY (IF (EVAL-PORT? BOX) (MAKE-PORT-TO THING) (COPY-FOR-EVAL THING)))))))
  418.  
  419. (DEFBOXER-FUNCTION GET-LABELLED (LABEL BOX)
  420.   (LET ((SYMBOL (GET-FIRST-ELEMENT LABEL)))
  421.     (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
  422.       FOR LABELS = (SUBSET #'LABEL-PAIR? ROW)
  423.       WHEN (NOT-NULL LABELS)
  424.         DO (LET ((WINNING-PAIR (MEM #'(LAMBDA (X Y) (EQ X (LABEL-PAIR-LABEL Y)))
  425.                     SYMBOL LABELS)))
  426.          (WHEN (NOT-NULL WINNING-PAIR)
  427.            (RETURN (COPY-FOR-EVAL (LABEL-PAIR-ELEMENT (CAR WINNING-PAIR))))))
  428.       FINALLY
  429.         (RETURN (MAKE-EMPTY-EVBOX)))))
  430.  
  431.  
  432.  
  433. ;;;; Constructors...
  434. ;;; MAKE-EMPTY-BOX, BOXIFY, JOIN-RIGHT, JOIN-BOTTOM, BUILD
  435.  
  436. (DEFBOXER-FUNCTION MAKE-EMPTY-BOX ()
  437.   (MAKE-EMPTY-EVBOX))
  438.  
  439. (DEFBOXER-FUNCTION BOXIFY (STUFF)
  440.   (BOXIFY STUFF))
  441.  
  442. (DEFBOXER-FUNCTION JOIN-RIGHT (BOX1 BOX2)
  443.   (LET ((ROWS1 (GET-ROWS-FOR-SELECTOR BOX1))
  444.     (ROWS2  (GET-ROWS-FOR-SELECTOR BOX2)))
  445.     (LOOP FOR INDEX FROM 0 TO (1- (MAX (LENGTH ROWS1) (LENGTH ROWS2)))
  446.       WITH LEFT-WID = (EVROWS-MAX-LENGTH-IN-CHAS ROWS1)
  447.       FOR ROW1 = (NTH INDEX ROWS1)
  448.       FOR ROW2 = (NTH INDEX ROWS2)
  449.       FOR PADDING = (IF (NULL ROW1) LEFT-WID (- LEFT-WID (EVROW-LENGTH-IN-CHAS ROW1)))
  450.       COLLECT (APPEND-EVROWS ROW1 (MAKE-EMPTY-EVROW PADDING) ROW2) INTO NEW-ROWS
  451.       FINALLY
  452.         (RETURN
  453.           (MAKE-EVDATA ROWS NEW-ROWS
  454.                BINDINGS (APPEND (GET-LOCAL-ENV BOX1) (GET-LOCAL-ENV BOX2)))))))
  455.  
  456. (DEFBOXER-FUNCTION JOIN-BOTTOM (BOX1 BOX2)
  457.   (MAKE-EVDATA ROWS (APPEND (GET-ROWS-FOR-SELECTOR BOX1) (GET-ROWS-FOR-SELECTOR BOX2))
  458.            BINDINGS (APPEND (GET-LOCAL-ENV BOX1) (GET-LOCAL-ENV BOX2))))
  459.  
  460. (DEFBOXER-FUNCTION BUILD ((BUILD TEMPLATE))
  461.   TEMPLATE)
  462.  
  463.  
  464.  
  465. ;;;; Mutators....
  466. ;;; CHANGE, CHANGE-ITEM, CHANGE-ROW, DELETE (?), DELETE-ITEM, DELETE-ROW, 
  467. ;;; INSERT-ITEM, INSERT-ROW
  468.  
  469. ;; dispatches on the type of value assuming a real box for the first arg
  470. (DEFUN CHANGE-BOX (BOX NEW-VALUE)
  471.   (COND ((OR (SYMBOLP NEW-VALUE) (NUMBERP NEW-VALUE))
  472.      (LET ((ROW (MAKE-ROW `(,NEW-VALUE))))
  473.        (TELL BOX :SET-FIRST-INFERIOR-ROW ROW)
  474.        (TELL ROW :SET-SUPERIOR-BOX BOX)
  475.        (TELL BOX :SET-STATIC-VARIABLES-ALIST NIL)
  476.        (TELL BOX :MODIFIED)
  477.        (TELL BOX :EXIT-FROM-SPRITE-INSTANCE-VAR)))
  478.     ((EVAL-PORT? NEW-VALUE)
  479.      (CHANGE-BOX BOX (GET-PORT-TARGET NEW-VALUE)))
  480.     ((EVAL-BOX? NEW-VALUE)
  481.      (TELL BOX :SET-STATIC-VARIABLES-ALIST NIL)
  482.      (TELL BOX :SET-CONTENTS-FROM-STREAM (MAKE-BOXER-STREAM NEW-VALUE) T T)
  483.      (TELL BOX :EXIT-FROM-SPRITE-INSTANCE-VAR)
  484.      (let ((ll (if (box? new-value)
  485.                (tell new-value :eval-inside-yourself 'local-library)
  486.                (get-evbox-local-library new-value))))
  487.        (unless (null ll)
  488.          (let ((new-ll (tell ll :copy)))
  489.            (tell box :set-local-library new-ll)
  490.            (tell new-ll :export-all-variables)
  491.            (tell box :add-static-variable-pair *exporting-box-marker* new-ll)))))
  492.     (T (FERROR "Don't know how to change ~A to be ~A" BOX NEW-VALUE))))
  493.  
  494.  
  495. ;; who cares where we put anything anymore
  496. (defun get-evbox-local-library (evbox)
  497.   (do* ((bindings
  498.       (evbox-bindings evbox)
  499.       (cdr bindings))
  500.     (item (car bindings) (car bindings)))
  501.        ((null bindings) nil)
  502.     (when (and (eq (car item) *exporting-box-marker*)
  503.            (ll-box? (cdr item)))
  504.       (return (cdr item)))))
  505.   
  506. (DEFUN CHANGE-EVBOX (EVBOX NEW-VALUE)
  507.   (COND ((OR (SYMBOLP NEW-VALUE) (NUMBERP NEW-VALUE))
  508.      (SETF (EVBOX-ROWS EVBOX) `(,(MAKE-EVROW-FROM-ENTRY NEW-VALUE))))
  509.     ((EVAL-PORT? NEW-VALUE)
  510.      (CHANGE-EVBOX EVBOX (GET-PORT-TARGET NEW-VALUE)))
  511.     ((EVAL-BOX? NEW-VALUE)
  512.      (SETF (EVBOX-ROWS EVBOX) (GET-ROWS-FOR-SELECTOR NEW-VALUE))
  513.      (let ((ll (get-evbox-local-library new-value)))
  514.        (unless (null ll)
  515.          (let ((new-ll (tell ll :copy)))
  516.            (tell new-ll :export-all-variables)
  517.            (add-static-variable-to-evbox evbox *exporting-box-marker* new-ll)))))
  518.     (T (FERROR "Don't Know how to change ~A to be ~A" EVBOX NEW-VALUE))))
  519.  
  520. ;; disptches on the type of BOX 
  521. (DEFUN CHANGE (BOX-OR-PORT NEW-VALUE)
  522.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  523.     (COND ((EVBOX? BOX) (CHANGE-EVBOX BOX NEW-VALUE))
  524.       ((BOX? BOX)   (CHANGE-BOX BOX NEW-VALUE))
  525.       (T (FERROR "Don't know how to CHANGE ~A" BOX)))))
  526.  
  527. (DEFBOXER-FUNCTION CHANGE((PORT-TO BOX) NEW-VALUE)
  528.   (CHANGE BOX NEW-VALUE)
  529.   ':NOPRINT)
  530.  
  531. (DEFBOXER-FUNCTION CHANGE-ITEM ((NUMBERIZE N) BOX NEW-ITEM)
  532.   (MULTIPLE-VALUE-BIND (ROW COL)
  533.       (GET-ROW-AND-COL-NUMBER N BOX)
  534.     (COND ((NULL ROW)
  535.        (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
  536.       (T
  537.        (CHANGE-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW (BOX-OR-PORT-TARGET BOX)
  538.                          (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX))))))
  539.  
  540. (DEFBOXER-FUNCTION CHANGE-RC ((numberize ROW) (numberize COL) BOX NEW-ITEM)
  541.   (CHANGE-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW) (BOX-OR-PORT-TARGET BOX)
  542.                     (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX)))
  543.  
  544. (DEFBOXER-FUNCTION CHANGE-ROW ((NUMBERIZE N) BOX NEW-ROW)
  545.   (CHANGE-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX)
  546.             (GET-FIRST-ROW-FOR-SELECTOR NEW-ROW) (EVAL-BOX? BOX)))
  547.  
  548. (DEFBOXER-FUNCTION DELETE-ITEM ((NUMBERIZE N) BOX)
  549.   (MULTIPLE-VALUE-BIND (ROW COL)
  550.       (GET-ROW-AND-COL-NUMBER N BOX)
  551.     (COND ((NULL ROW)
  552.        (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
  553.       (T
  554.        (DELETE-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW
  555.                          (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX))))))
  556.  
  557. (DEFBOXER-FUNCTION DELETE-RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX)
  558.   (DELETE-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW)
  559.                     (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX)))
  560.  
  561. (DEFBOXER-FUNCTION DELETE-ROW ((NUMBERIZE N) BOX)
  562.   (DELETE-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX)))
  563.  
  564. (DEFBOXER-FUNCTION INSERT-ITEM ((NUMBERIZE N) BOX NEW-ITEM)
  565.   (MULTIPLE-VALUE-BIND (ROW COL)
  566.       (GET-ROW-AND-COL-NUMBER N BOX)
  567.     (COND ((AND (NULL ROW) (= N (1+ (GET-BOX-LENGTH-IN-ELEMENTS BOX))))
  568.        (LET* ((LAST-ROW-NO (1- (GET-BOX-LENGTH-IN-ROWS BOX)))
  569.           (LAST-COL-NO (LENGTH (GET-NTH-ROW LAST-ROW-NO BOX))))
  570.          (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1+ LAST-COL-NO) LAST-ROW-NO
  571.                            (BOX-OR-PORT-TARGET BOX)
  572.                            (GET-FIRST-ELEMENT NEW-ITEM)
  573.                            (EVAL-BOX? BOX))))
  574.       ((NULL ROW)
  575.        (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
  576.       (T
  577.        (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW (BOX-OR-PORT-TARGET BOX)
  578.                          (GET-FIRST-ELEMENT NEW-ITEM)
  579.                          (EVAL-BOX? BOX))))))
  580.  
  581. (DEFBOXER-FUNCTION INSERT-RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX NEW-ITEM)
  582.   (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW) (BOX-OR-PORT-TARGET BOX)
  583.                     (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX)))
  584.  
  585. (DEFBOXER-FUNCTION INSERT-ROW ((NUMBERIZE N) BOX NEW-ROW)
  586.   (INSERT-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX)
  587.             (GET-FIRST-ROW-FOR-SELECTOR NEW-ROW) (EVAL-BOX? BOX)))
  588.  
  589. ;;  Needs more robustness and arg checking
  590. (DEFBOXER-FUNCTION INSERT-NAMED ((PORT-TO BOX) NAME)
  591.   (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1+ (LENGTH (GET-NTH-ROW
  592.                           (1- (GET-BOX-LENGTH-IN-ROWS BOX)) BOX)))
  593.                     (1- (GET-BOX-LENGTH-IN-ROWS BOX))
  594.                     (BOX-OR-PORT-TARGET BOX)
  595.                     (MAKE-BOX '(()) ':DATA-BOX (GET-FIRST-ELEMENT NAME))
  596.                     (EVAL-BOX? BOX)))
  597.  
  598.  
  599.  
  600. ;;; Characters  Words
  601.  
  602. (DEFUN EXPLODE-ROW (ROW)
  603.   (LOOP FOR ENTRY IN (MAPCAR #'ROW-ENTRY-ELEMENT ROW)
  604.     APPENDING (IF (EVAL-BOX? ENTRY) (NCONS ENTRY)
  605.               (MAPCAR #'(LAMBDA (X) (FORMAT NIL "~C" X))
  606.                   (LISTARRAY (STRINGIFY ENTRY))))))
  607.     
  608.  
  609. (defun implode-row (row)
  610.   (let ((string (make-array 0 :type 'art-string)))
  611.     (loop for entry in (mapcar #'row-entry-element row) do
  612.       (setq string (string-append string
  613.                   (if (box? entry) (send entry :text-string)
  614.                       (stringify entry)))))
  615.     (make-evrow-from-entry (intern string 'bu))))
  616.  
  617. (DEFBOXER-FUNCTION CHARACTERS (BOX)
  618.   (LET ((ROWS (GET-BOX-ROWS BOX)))
  619.     (MAKE-EVDATA ROWS (MAPCAR #'EXPLODE-ROW ROWS))))
  620.  
  621. (defboxer-function words (box)
  622.   (let ((rows (get-box-rows box)))
  623.     (make-evdata rows (mapcar #'implode-row rows))))
  624.  
  625. (defboxer-function substring ((port-to box) startnum endnum)
  626.   (let* ((string-box (box-or-port-target box))
  627.      (string (tell string-box :text-string)))
  628.     (substring string startnum endnum)))
  629.  
  630. ;;; Doit  Data
  631.  
  632. ;;; TEXT takes either the name of a DOIT box or a DOIT box as input and returns
  633. ;;; a DATA box containing the text (i.e., the rows) of the specified DOIT box.
  634. (DEFBOXER-FUNCTION TEXT ((DATAFY BOX-OR-NAME))
  635.   (LET ((OBJECT (GET-FIRST-ELEMENT BOX-OR-NAME)))
  636.     (IF (SYMBOLP OBJECT) (SETQ OBJECT (BOXER-SYMEVAL OBJECT)))
  637.     (MAKE-EVDATA ROWS (MAPCAR #'MAKE-EVROW-FROM-ITEMS (GET-BOX-ROWS OBJECT T)))))
  638.